Otherware/Otherware_1_SB_Development.iso/mac/developm/source/rclesrc.10/ircle sources/IRCInput.p

Text File | 1992-09-06 | 7.5 KB | 348 lines

{    ircle - Internet Relay Chat client    }
{    File: IRCInput    }
{    Copyright ⌐ 1992 Olaf Titz ([e-mail])    }

{    This program is free software; you can redistribute it and/or modify    }
{    it under the terms of the GNU General Public License as published by    }
{    the Free Software Foundation; either version 2 of the License, or    }
{    (at your option) any later version.    }

{    This program is distributed in the hope that it will be useful,    }
{    but WITHOUT ANY WARRANTY; without even the implied warranty of    }
{    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the    }
{    GNU General Public License for more details.    }

{    You should have received a copy of the GNU General Public License    }
{    along with this program; if not, write to the Free Software    }
{    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.    }

unit IRCInput;
{ Handles input from the user and sends messages to the server. }
{ Handles lines sent from the server. }
{ And handles menu commands. }

interface
uses
    TCPTypes, TCPStuff, TCPConnections, Coroutines, ApplBase, MsgWindows, InputLine, {}
    IRCGlobals, IRCaux, IRCPreferences, IRCChannels, IRCCommands, DCC, IRCSComm;

procedure InitIRCInput;
{ Startup }

procedure OpenConnection;
{ open connection & do autoexec }

implementation

type
    str20 = string[20];
    CEPtr = ^ConnectionEventRecord;

var
    prevcr: boolean;
    ip: longint;


procedure PasteCommand (s: str20);  { Set the input line to a command }
    begin
        s := concat(cmdchar, s);
        SetInputLine(s);
    end;

function MenuFILE (var e: EventRecord): boolean;
    var
        i: integer;
        s: string;
    begin
        MenuFILE := true;
        case loword(e.message) of
            M_F_OPEN:
                OpenConnection;
            M_F_CLOSE:
                if GetWRefCon(FrontWindow) <> 0 then
                    partWindow(FrontWindow);
            M_F_LOG:
                begin
                if logging then begin
                    close(logfile);
                    logging := false
                end
                else begin
                    s := NewFileName('Save log to file:');
                    if s <> '' then begin
                        rewrite(logfile, s);
                        logging := true
                    end
                end;
            end;
            M_F_FLUSH:
                begin
                flushing := true;
                UpdateStatusLine
            end;
            M_F_PREFS:
                begin
                ValidPrefs := GetPrefs(true);
                if ValidPrefs then
                    EnableItem(GetMHandle(M_SHCUTS), 0);
            end;
            M_F_QUIT:
                begin
                if serverStatus = 0 then begin
                    if Alert(A_QUIT, nil) <> 1 then
                        exit(menuFILE);
                    s := 'QUIT';
                    HandleCommand(s);    { try a regular exit }
                end;
                ApplExit; { Emergency exit - will give 'bad link' as reason }
            end;
        end;
    end;

function MenuCOMMANDS (var e: EventRecord): boolean;
    begin
        case loword(e.message) of
            M_CO_JOIN:
                PasteCommand('join ');
            M_CO_PART:
                PasteCommand('part ');
            M_CO_LIST:
                PasteCommand('list ');
            M_CO_WHO:
                PasteCommand('who ');
            M_CO_QUERY:
                PasteCommand('query ');
            M_CO_WHOIS:
                PasteCommand('whois ');
            M_CO_INVITE:
                PasteCommand('invite ');
            M_CO_KICK:
                PasteCommand('kick ');
            M_CO_AWAY:
                PasteCommand('away ');
            M_CO_MSG:
                PasteCommand('msg ');
        end;
        MenuCOMMANDS := true
    end;


function MenuSHCUTS (var e: EventRecord): boolean;
    var
        s: string;
    begin
        if e.message = M_SH_DEFINE then
            GetShortcuts
        else begin
            s := Shortcuts^^[loword(e.message) - M_SH_FIRST];
            if s <> '' then
                InsertInputLine(s);
        end;
        MenuSHCUTS := true
    end;

function MenuFONTS (var e: EventRecord): boolean;
    var
        s: Str255;
        p0: GrafPtr;
        m: MenuHandle;
        i: integer;
    begin
        m := GetMHandle(262);
        case loword(e.message) of
            M_FO_9:
                MWDefaultSize := 9;
            M_FO_10:
                MWDefaultSize := 10;
            M_FO_12:
                MWDefaultSize := 12;
            M_FO_14:
                MWDefaultSize := 14;
            otherwise
                begin
                GetItem(m, LoWord(e.message), s);
                GetFNum(s, MWDefaultFont);
            end
        end;
        if e.message < 5 then
            for i := 1 to 4 do
                CheckItem(m, i, (i = Loword(e.message)))
        else
            for i := 6 to CountMItems(m) do
                CheckItem(m, i, (i = Loword(e.message)));
        if MWActive <> nil then begin
            GetPort(p0);
            SetPort(MWActive^^.w);
            SetFontSize(MWActive, MWDefaultFont, MWDefaultSize);
            SetPort(p0)
        end;
        MenuFONTS := true;
    end;

{ Process a typed line as message. }
{ This means: convert it to a PRIVMSG command to the current target, }
{ i.e. the channel or query of the active window. }
procedure HandleMessage (var s: string);
    var
        c: string;
    begin
        if currentTarget = '' then
            StatusMsg(E_NOTARGET)
        else if CurrentTarget[1] = DCC_CHAT_PREFIX then
            DCCChatSend(s)
        else begin
            c := concat('PRIVMSG ', CurrentTarget, ' :', s);
            HandleCommand(c);
            c := concat('> ', s);
            Message(c);
            s := '';
        end;
    end;

{ 'srvHandler' handles lines received from server }
procedure srvHandler (var s: string; cr: boolean);
    begin
        if s[0] <> chr(0) then
            if prevcr then
                ServerCommands(s)
            else
                MWMessage(lastwindow, s);
        prevcr := cr;
    end;

{ 'InputHandler' process handles input from the user }
procedure InputHandler (var s: string);
    begin
        GetDateTime(idleTime);
        if s[0] <> chr(0) then
            if serverStatus = S_CONN then
                if s[1] = CmdChar then
                    HandleCommand(s)
                else
                    HandleMessage(s);
    end;

function watchFound (var e: EventRecord): boolean;
    var
        c: CEPtr;
    begin
        c := CEPtr(e.message);
        if c^.connection <> sSocket then begin
            watchFound := false;
            exit(watchFound)
        end
        else
            watchFound := true;
        if c^.event = C_Found then
            ip := c^.value
        else if c^.event = C_SearchFailed then
            ip := -1
        else
            watchFound := false
    end;

function watchOpen (var e: EventRecord): boolean;
    var
        c: CEPtr;
    begin
        c := CEPtr(e.message);
        if c^.connection <> sSocket then begin
            watchOpen := false;
            exit(watchOpen)
        end
        else
            watchOpen := true;
        if c^.event = C_Established then
            ip := 0
        else if c^.event = C_FailedToOpen then
            ip := -1
        else
            watchOpen := false
    end;

function watchLine (var e: EventRecord): boolean;
    var
        c: CEPtr;
        s: string;
        nn: longint;
        i, j: integer;
        cr: boolean;
    begin
        c := CEPtr(e.message);
        if c^.connection = sSocket then begin
            nn := 1;
            i := TCPReceiveUpTo(c^.tcpc, 10, readTimeout, @s[0], 250, nn, cr);
            j := nn - 1;
            while (j > 0) and (s[j] in [chr(10), chr(13)]) do
                j := pred(j);
            s[0] := chr(j);
            for i := 1 to j do
                s[i] := ISODecode^^[s[i]];
            srvHandler(s, cr);
            watchLine := true
        end
        else
            watchLine := false;
    end;

procedure OpenConnection;
    var
        e: integer;
    begin
        if not validPrefs then
            validPrefs := GetPrefs(true);
        if validPrefs and (serverStatus <> 0) then begin
            CurrentNick := default^^.Nick;
            SetMainTitle(CurrentNick);
            serverStatus := S_LOOKUP;
            UpdateStatusLine;
            SetCursor(Watch^^);
            e := FindAddress(sSocket, default^^.server, nil);
            if e = 0 then begin
                ip := 0;
                e := ApplTask(@watchFound, TCPMsg);
                repeat
                    ApplRun
                until ip <> 0;
                ApplUNtask(e);
                if ip <> -1 then begin
                    serverStatus := S_OPENING;
                    UpdateStatusLine;
                    e := NewActiveConnection(sSocket, 8192, ip, default^^.port, nil);
                    if e = 0 then begin
                        e := ApplTask(@watchOpen, TCPMsg);
                        repeat
                            ApplRun
                        until ip = 0;
                        ApplUNtask(e);
                        if ip <> -1 then begin
                            e := 0;
                            serverStatus := S_CONN;
                            RegUser;
                        end
                        else
                            e := ord(C_FailedToOpen);
                    end
                end
                else
                    e := ord(C_SearchFailed);
            end
        end;
        InitCursor;
        serverOK(e);
    end;


procedure InitIRCInput;
    var
        i: integer;
    begin
        OpenInputLine(@InputHandler);
        i := ApplTask(@MenuFILE, menuMsg + fileMenu);
        i := ApplTask(@MenuCOMMANDS, menuMsg + M_COMMANDS);
        i := ApplTask(@MenuSHCUTS, menuMsg + M_SHCUTS);
        i := ApplTask(@MenuFONTS, menuMsg + M_FONT);
        i := ApplTask(@watchLine, TCPMsg);
    end;

end.